home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Planet Source Code Jumbo …e CD Visual Basic 1 to 7
/
4_2005-2006.ISO
/
data
/
Zips
/
CaptureScr2152985232009.psc
/
AVItoGIF 1.0
/
AVI2GiffMain.frm
< prev
next >
Wrap
Text File
|
2008-03-27
|
24KB
|
769 lines
VERSION 5.00
Begin VB.Form AVI2Gif
BorderStyle = 1 'Fixed Single
Caption = "AVItoGIF"
ClientHeight = 5550
ClientLeft = 45
ClientTop = 615
ClientWidth = 7695
ClipControls = 0 'False
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "AVI2GiffMain.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 370
ScaleMode = 3 'Pixel
ScaleWidth = 513
StartUpPosition = 2 'CenterScreen
Begin VB.PictureBox iPalette
BackColor = &H00FFFFFF&
ClipControls = 0 'False
ForeColor = &H00808080&
Height = 1500
Left = 6000
ScaleHeight = 96
ScaleMode = 3 'Pixel
ScaleWidth = 96
TabIndex = 8
TabStop = 0 'False
Top = 1335
Width = 1500
End
Begin VB.Timer tmrDelay
Enabled = 0 'False
Left = 5220
Top = 4620
End
Begin VB.CommandButton cmdPickColor
Caption = "Pick &color"
Enabled = 0 'False
Height = 405
Left = 6000
TabIndex = 11
TabStop = 0 'False
Top = 3960
Width = 1170
End
Begin VB.CheckBox chkTransparent
Appearance = 0 'Flat
Caption = "&Transparent"
Enabled = 0 'False
ForeColor = &H80000008&
Height = 240
Left = 6000
TabIndex = 10
TabStop = 0 'False
Top = 3600
Width = 1335
End
Begin AVItoGIF.ucCanvas ucCanvas
Height = 5025
Left = 120
TabIndex = 0
TabStop = 0 'False
Top = 165
Width = 5685
_ExtentX = 10028
_ExtentY = 8864
End
Begin AVItoGIF.ucProgress ucProgress
Align = 2 'Align Bottom
Height = 225
Left = 0
Top = 5325
Width = 7695
_ExtentX = 13573
_ExtentY = 397
BorderStyle = 1
End
Begin VB.Label lblEntriesV
Alignment = 1 'Right Justify
ForeColor = &H80000015&
Height = 210
Left = 6375
TabIndex = 9
Top = 2865
Width = 1125
End
Begin VB.Label lblPaletteV
Height = 195
Left = 6675
TabIndex = 7
Top = 1005
Width = 900
End
Begin VB.Label lblPalette
Caption = "Palette:"
Height = 195
Left = 6015
TabIndex = 6
Top = 1005
Width = 735
End
Begin VB.Label Label1
Caption = "Note: Enable/disable transparency before GIF optimization."
ForeColor = &H80000015&
Height = 660
Left = 6000
TabIndex = 12
Top = 4590
Width = 1575
WordWrap = -1 'True
End
Begin VB.Label lblScreenV
Height = 195
Left = 6675
TabIndex = 3
Top = 450
Width = 900
End
Begin VB.Label lblFramesV
Height = 195
Left = 6675
TabIndex = 5
Top = 720
Width = 900
End
Begin VB.Label lblScreen
Caption = "Screen:"
Height = 195
Left = 6015
TabIndex = 2
Top = 450
Width = 735
End
Begin VB.Label lblFrames
Caption = "Frames:"
Height = 195
Left = 6015
TabIndex = 4
Top = 720
Width = 735
End
Begin VB.Label lblInfo
Caption = "GIF info:"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
Left = 6015
TabIndex = 1
Top = 150
Width = 1260
End
Begin VB.Menu mnuFileTop
Caption = "&File"
Begin VB.Menu mnuFile
Caption = "&Import AVI..."
Index = 0
Shortcut = ^I
End
Begin VB.Menu mnuFile
Caption = "&Save test GIF"
Index = 1
Shortcut = ^S
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 2
End
Begin VB.Menu mnuFile
Caption = "&Optimize GIF"
Index = 3
Shortcut = ^O
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 4
End
Begin VB.Menu mnuFile
Caption = "E&xit"
Index = 5
End
End
Begin VB.Menu mnuOptionsTop
Caption = "&Options"
Begin VB.Menu mnuOptions
Caption = "Ordered dither"
Index = 0
End
Begin VB.Menu mnuOptions
Caption = "Use optimal (first frame)"
Index = 1
End
End
Begin VB.Menu mnuHelpTop
Caption = "&Help"
Begin VB.Menu mnuHelp
Caption = "&About"
Index = 0
End
End
End
Attribute VB_Name = "AVI2Gif"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'================================================
' Project: AVItoGIF
' Author: Carles P.V. (*)
' Last revision: 2003.09.06
'================================================
' Commercial use not permitted!
' Email author/s please.
'================================================
'
' (*) All thanks to Vlad Vissoultchev & Ron van Tilburg
' for GIF Decode/Encode original routines.
'
' Notes:
'
' This 'AVI to GIF' converter is quite 'simple':
' - Optimal palette is got from the first frame.
' - Simple GIF size optimization (M.B.R.).
'
' I'm working now on better GIF optimization. I'll post
' it as soon as possible (I hope).
'
' Please, let me know for any bug/s, speed improvements,
' etc. Thanks.
Option Explicit
Private m_oGIF As New cGIF ' Our GIF object
Private m_oBackground As New cTile ' Frame rendering
Private m_oDIBRestore As New cDIB ' Frame rendering
Private m_bTransparent As Boolean ' Transparency
Private m_nTransparentIdx As Integer ' Transparent palette entry
Private m_nFrame As Integer ' Current frame
Private m_nFrames As Integer ' Number of frames
Private m_sFilename As String ' Last file path (AVI import)
Private m_bPicking As Boolean ' Picking transparent color
Dim AVIFile As String
Dim sTmpFilename As String
Private Sub Form_Activate()
Dim Strng As String
If Command$ <> "" And Left(Command$, 1) <> "1" Then
AVIFile = App.Path & "\MyAVI.avi"
ImportAVI
Optimum
SaveGif
Unload Me
End If
If Command$ <> "" And Left(Command$, 1) = "1" Then
AVIFile = App.Path & "\MyAVI.avi"
ImportAVI
'Optimum
'SaveGif
End If
'With mnuOptions(1)
'.Checked = Not .Checked
'mDither8bpp.Palette = -.Checked * [ipOptimal]
'End With
'With mnuOptions(0)
'.Checked = Not .Checked
'mDither8bpp.DitherMethod = -.Checked * [idmOrdered]
'End With
'mnuOptions_Click (0)
'mnuOptions_Click (1)
End Sub
'//
Private Sub Form_Load()
SetTopMostWindow Me.hWnd, True
'-- Initalize mDither8bpp module
mDither8bpp.InitializeLUTs
mDither8bpp.Palette = [ipBrowser]
mDither8bpp.DitherMethod = [idmNone]
'-- Initalize pattern brush (empty palette entry)
mMisc.InitializePatternBrush
'-- Load canvas custom cursor
Set ucCanvas.UserIcon = LoadResPicture("CURSOR_PICKCOLOR", vbResCursor)
'-- Hook mouse wheel for zooming support
mWheel.HookWheel
End Sub
Private Sub Form_Paint()
'-- Some decorative lines
Me.Line (0, 0)-(ScaleWidth, 0), vb3DShadow
Me.Line (0, 1)-(ScaleWidth, 1), vb3DHighlight
End Sub
Private Sub Form_Unload(Cancel As Integer)
'-- Destroy GIF and rendering buffers
pvCleanUp
'-- Destroy pattern brush (empty palette entry)
mMisc.DestroyPatternBrush
'-- Is next line necessary [?]
Set AVI2Gif = Nothing
End
End Sub
'//
Private Sub mnuFile_Click(Index As Integer)
Select Case Index
Case 0 '-- Import AVI...
'-- Show open file dialog
sTmpFilename = mDialogFile.GetFileName(m_sFilename, "AVI files (*.avi)|*.AVI", , "Load AVI file", -1)
'sTmpFilename = AVIFile
If (Len(sTmpFilename)) Then
m_sFilename = sTmpFilename
'-- Stop animation
tmrDelay.Enabled = 0
'-- Destroy current GIF
m_oGIF.Destroy
'-- Disable transparency
chkTransparent.Enabled = -1
chkTransparent = 0
cmdPickColor.Enabled = 0
m_bTransparent = 0
m_nTransparentIdx = 0
'-- Import AVI frames...
DoEvents
If (mAVIImp.ImportAVI(m_sFilename, m_oGIF, ucProgress)) Then
pvInitialize
pvShowInfo
Else
MsgBox "Unexpected error loading AVI file.", vbExclamation
pvCleanUp
pvShowInfo
End If
End If
Case 1 '-- Save GIF...
If (m_oGIF.FramesCount = 0) Then
'-- No GIF
MsgBox "Nothing to save", vbExclamation
Else
'-- Save as test file (Test.gif)
DoEvents
Screen.MousePointer = vbArrowHourglass
If (Not m_oGIF.Save(App.Path & IIf(Right$(App.Path, 1) <> "\", "\", "") & "Test.gif")) Then
Screen.MousePointer = vbDefault
MsgBox "Unexpected error saving GIF file.", vbExclamation
Else
Screen.MousePointer = vbDefault
End If
End If
Case 3 ' -- Optimize GIF
If (m_oGIF.FramesCount = 0) Then
'-- Nothing to optimize
MsgBox "Nothing to optimize", vbExclamation
Else
'-- Remove unused entries and get minimum bounding rectangles
tmrDelay.Enabled = 0
DoEvents
mGIFExt.OptimizeGlobalPalette m_oGIF, ucProgress: m_nTransparentIdx = m_oGIF.FrameTransparentColorIndex(1)
mGIFExt.OptimizeFrames m_oGIF, ucProgress
'-- Initialize
pvInitialize
pvShowInfo
'-- Disable transparency controls
chkTransparent.Enabled = 0
cmdPickColor.Enabled = 0
'-- Disable Picking mode [?]
If (m_bPicking) Then
m_bPicking = 0
ucCanvas.WorkMode = [cnvScrollMode]
End If
End If
Case 5 ' -- Exit
Unload Me
End Select
End Sub
Private Sub Optimum()
tmrDelay.Enabled = 0
DoEvents
mGIFExt.OptimizeGlobalPalette m_oGIF, ucProgress: m_nTransparentIdx = m_oGIF.FrameTransparentColorIndex(1)
mGIFExt.OptimizeFrames m_oGIF, ucProgress
'-- Initialize
pvInitialize
pvShowInfo
'-- Disable transparency controls
chkTransparent.Enabled = 0
cmdPickColor.Enabled = 0
'-- Disable Picking mode [?]
If (m_bPicking) Then
m_bPicking = 0
ucCanvas.WorkMode = [cnvScrollMode]
End If
End Sub
Private Sub SaveGif()
If (m_oGIF.FramesCount = 0) Then
'-- No GIF
MsgBox "Nothing to save", vbExclamation
Else
'-- Save as test file (Test.gif)
DoEvents
Screen.MousePointer = vbArrowHourglass
If (Not m_oGIF.Save(App.Path & IIf(Right$(App.Path, 1) <> "\", "\", "") & "Test.gif")) Then
Screen.MousePointer = vbDefault
MsgBox "Unexpected error saving GIF file.", vbExclamation
Else
Screen.MousePointer = vbDefault
End If
End If
End Sub
Private Sub ImportAVI()
'-- Show open file dialog
'sTmpFilename = mDialogFile.GetFileName(m_sFilename, "AVI files (*.avi)|*.AVI", , "Load AVI file", -1)
sTmpFilename = AVIFile
If (Len(sTmpFilename)) Then
m_sFilename = sTmpFilename
'-- Stop animation
tmrDelay.Enabled = 0
'-- Destroy current GIF
m_oGIF.Destroy
'-- Disable transparency
chkTransparent.Enabled = -1
chkTransparent = 0
cmdPickColor.Enabled = 0
m_bTransparent = 0
m_nTransparentIdx = 0
'-- Import AVI frames...
DoEvents
If (mAVIImp.ImportAVI(m_sFilename, m_oGIF, ucProgress)) Then
pvInitialize
pvShowInfo
Else
MsgBox "Unexpected error loading AVI file.", vbExclamation
pvCleanUp
pvShowInfo
End If
End If
End Sub
Private Sub mnuOptions_Click(Index As Integer)
Select Case Index
Case 0 '-- Ordered dither
With mnuOptions(0)
.Checked = Not .Checked
mDither8bpp.DitherMethod = -.Checked * [idmOrdered]
End With
Case 1 '-- Use optimal
With mnuOptions(1)
.Checked = Not .Checked
mDither8bpp.Palette = -.Checked * [ipOptimal]
End With
End Select
End Sub
Private Sub mnuHelp_Click(Index As Integer)
'-- Simple About box...
MsgBox "AVItoGIF v" & App.Major & "." & App.Minor & vbCrLf & vbCrLf & _
"Simple AVI to GIF converter + Basic GIF size optimization" & vbCrLf & vbCrLf & _
"All thanks to Vlad Vissoultchev & Ron van Tilburg" & vbCrLf & _
"for GIF Decode/Encode original routines."
End Sub
'//
Private Sub chkTransparent_Click()
Dim nFrm As Integer
If (m_oGIF.FramesCount) Then
'-- Update controls
m_bTransparent = -chkTransparent
cmdPickColor.Enabled = -chkTransparent
'-- Re-mask frames
Screen.MousePointer = vbHourglass
mGIFExt.RemaskFrames m_oGIF, m_bTransparent, m_nTransparentIdx, ucProgress
Screen.MousePointer = vbDefault
'-- Re-start animation
pvInitialize
End If
End Sub
Private Sub cmdPickColor_Click()
'-- Enable color picking
If (m_bTransparent) Then
m_bPicking = -1
ucCanvas.WorkMode = [cnvUserMode]
'-- Show first (full) frame
tmrDelay.Enabled = 0
m_nFrame = 1
pvFrame_Change
End If
End Sub
'//
Private Sub ucCanvas_MouseDown(Button As Integer, Shift As Integer, X As Long, Y As Long)
'-- Force ucCanvas_MouseMove sub.
If (m_bPicking And ucCanvas.DIB.hDIB <> 0) Then
ucCanvas_MouseMove Button, Shift, X, Y
End If
End Sub
Private Sub ucCanvas_MouseMove(Button As Integer, Shift As Integer, X As Long, Y As Long)
If (Button = vbLeftButton) Then
If (m_bPicking And m_oGIF.FramesCount) Then
With m_oGIF
If (X >= .FrameLeft(1) And _
Y >= .FrameTop(1) And _
X < .FrameDIBXOR(1).Width - .FrameLeft(1) And _
Y < .FrameDIBXOR(1).Height - .FrameTop(1)) Then
'-- Get palette index (NOT color)
m_nTransparentIdx = mDither8bpp.PaletteIndex(.FrameDIBXOR(m_nFrame), X + .FrameLeft(1), Y + .FrameTop(1))
End If
End With
End If
End If
End Sub
Private Sub ucCanvas_MouseUp(Button As Integer, Shift As Integer, X As Long, Y As Long)
Dim nFrm As Integer
Dim lClr As Long
Select Case Button
Case vbLeftButton
If (m_bPicking) Then
m_bPicking = 0
ucCanvas.WorkMode = [cnvScrollMode]
'-- Re-mask frames
Screen.MousePointer = vbHourglass
mGIFExt.RemaskFrames m_oGIF, m_bTransparent, m_nTransparentIdx, ucProgress
Screen.MousePointer = vbDefault
'-- Re-start animation
pvInitialize
End If
Case vbRightButton
'-- Change background color
lClr = mDialogColor.SelectColor(Me.hWnd, ucCanvas.BackColor)
If (lClr <> -1) Then
ucCanvas.BackColor = lClr
If (m_oGIF.FramesCount) Then pvInitialize
End If
End Select
End Sub
'//
Private Sub pvCleanUp()
Set m_oGIF = Nothing
Set ucCanvas.DIB = Nothing
Set m_oBackground = Nothing
Set m_oDIBRestore = Nothing
End Sub
Private Sub pvInitialize()
'-- Stop timer
tmrDelay.Enabled = 0
'-- Paint palette
pvPaintPalette
'-- Initialize buffers
With m_oGIF
'-- Get number of frames
m_nFrames = .FramesCount
'-- Create canvas DIB
ucCanvas.DIB.Create .ScreenWidth, .ScreenHeight, [32_bpp]
ucCanvas.Resize
'-- Create restoring DIB
m_oDIBRestore.Create .ScreenWidth, .ScreenHeight, [24_bpp]
'-- Create background pattern (solid color) and initialize DIBs
m_oBackground.SetPatternFromSolidColor ucCanvas.BackColor
m_oBackground.Tile ucCanvas.DIB.hDC, 0, 0, .ScreenWidth, .ScreenHeight
m_oBackground.Tile m_oDIBRestore.hDC, 0, 0, .ScreenWidth, .ScreenHeight
'-- Start animation [?]
If (m_nFrames > 1) Then
'-- Enable timer
m_nFrame = m_nFrames
tmrDelay.Interval = 1
tmrDelay.Enabled = -1
Else
'-- Render only first frame
.FrameDraw ucCanvas.DIB.hDC, 1: ucCanvas.Repaint
End If
End With
End Sub
Private Sub tmrDelay_Timer()
'-- Next frame / First
If (m_nFrame < m_nFrames) Then
m_nFrame = m_nFrame + 1
Else
m_nFrame = 1
End If
pvFrame_Change
End Sub
Private Sub pvFrame_Change()
With m_oGIF
'-- Set current frame delay
Select Case .FrameDelay(m_nFrame)
Case Is < 0
tmrDelay.Interval = 60000 ' Max.: 1 min.
Case Is = 0
tmrDelay.Interval = 100 ' Def.: 0.1 sec.
Case Is < 5
tmrDelay.Interval = 50 ' Min.: 0.05 sec.
Case Else
tmrDelay.Interval = .FrameDelay(m_nFrame) * 10
End Select
'-- Restore:
If (m_nFrame = 1) Then
m_oBackground.Tile ucCanvas.DIB.hDC, 0, 0, .ScreenWidth, .ScreenHeight
Else
ucCanvas.DIB.LoadBlt m_oDIBRestore.hDC
End If
'-- Draw current frame:
.FrameDraw ucCanvas.DIB.hDC, m_nFrame
'-- Update restoring buffer:
Select Case .FrameDisposalMethod(m_nFrame)
Case [dmNotSpecified], [dmDoNotDispose]
'-- Update from current
m_oDIBRestore.LoadBlt ucCanvas.DIB.hDC
Case [dmRestoreToBackground]
'-- Update from background
m_oBackground.Tile m_oDIBRestore.hDC, .FrameLeft(m_nFrame), .FrameTop(m_nFrame), .FrameDIBXOR(m_nFrame).Width, .FrameDIBXOR(m_nFrame).Height, 0
Case [dmRestoreToPrevious]
'-- Preserve buffer
End Select
End With
'-- Paint frame
ucCanvas.Repaint
End Sub
Private Sub pvShowInfo()
Dim aBPP As Byte
Select Case True
Case ucCanvas.DIB.hDIB <> 0
'-- Calc. GIF palette color depth
Do: aBPP = aBPP + 1
Loop Until 2 ^ aBPP >= m_oGIF.GlobalPaletteEntries
'-- Show AVI props.
lblScreenV.Caption = m_oGIF.ScreenWidth & "x" & m_oGIF.ScreenHeight
lblFramesV.Caption = m_oGIF.FramesCount
lblPaletteV.Caption = aBPP & " bpp"
lblEntriesV.Caption = m_oGIF.GlobalPaletteEntries & " entries"
Case ucCanvas.DIB.hDIB = 0
'-- Reset AVI props.
lblScreenV.Caption = ""
lblFramesV.Caption = ""
lblPaletteV.Caption = ""
lblEntriesV.Caption = ""
End Select
End Sub
'//
Private Sub iPalette_Paint()
pvPaintPalette
End Sub
Private Sub pvPaintPalette()
Dim i As Long, j As Long
Dim lIdx As Long
Dim lClr As Long
'-- Show the 256 entries
For i = 0 To 90 Step 6
For j = 0 To 90 Step 6
With m_oGIF
If (lIdx < .GlobalPaletteEntries) Then
lClr = .GlobalPaletteRGBEntry(lIdx)
Else
lClr = -1
End If
mMisc.DrawRectangle iPalette.hDC, j, i, j + 6, i + 6, lClr
lIdx = lIdx + 1
End With
Next j
Next i
End Sub